;;;; RLlib copyright 2010 Adam White (theroguemonkey@gmail.com)
;;;; Licensed under GNU General Public Licence v2 or later - refer COPYING

(in-package #:rllib)

;;;;============================================================================
;;;; Callbacks
;;;;============================================================================

(defun callbacks (callback-stack &rest args)
  "Call all CALLBACK-STACK functions. Stops when a callback returns :end"
  (loop for f in callback-stack thereis (eq (apply (cdr f) args) :end)))

(defun idle (idle-stack)
  "Call all IDLE-STACK functions. Stops when a callback returns :end"
  (loop for f in idle-stack thereis (eq (funcall (cdr f)) :end)))

(defmacro push-callback (callback-stack realm function)
  "Add a new input callback FUNCTION to the CALLBACK-STACK stack. 
Args follow (lambda (TYPE &key button x y sym mod &allow-other-keys)).
REALM is a tag defining the callback type."
  `(setf ,callback-stack (acons ,realm ,function ,callback-stack)))

(defmacro push-idle (idle-stack realm function)
  "Add a new idle callback FUNCTION to the stack. No args accepted. 
REALM is a tag defining the callback type."
  `(setf ,idle-stack (acons ,realm ,function ,idle-stack)))

(defmacro push-callback+idle (callback-stack idle-stack realm funcs)
  "Add a new input callback and idle callback. FUNCS is a list of two callbacks.
REALM is the tag defining the callback type for each"
  `(progn
     (push-callback ,callback-stack ,realm (first ,funcs))
     (push-idle ,idle-stack ,realm (second ,funcs))))

(defmacro pop-callback (callback-stack realm)
  "Remove the top input callback matching REALM"
  `(setf ,callback-stack (delete ,realm callback-stack :key #'car :count 1)))

(defmacro pop-idle (idle-stack realm)
  "Remove the top idle callback matching REALM"
  `(setf ,idle-stack (delete ,realm ,idle-stack :key #'car :count 1)))


;;;============================================================================
;;;; Panels
;;;;============================================================================

(defclass panel ()
  ((x
    :initarg :x
    :reader panel-x)
   (y
    :initarg :y
    :reader panel-y)
   (w
    :initarg :w
    :reader panel-w)
   (h
    :initarg :h
    :reader panel-h)
   (xywh
    :initform nil
    :reader panel-xywh)
   (background
    :initform nil
    :initarg :bg
    :accessor panel-background)
   (effects
    :initform nil
    :accessor panel-effects)))

(defmethod initialize-instance :after ((panel panel) &key x y w h)
  (setf (slot-value panel 'xywh) (list (or x 0) (or y 0) (or w *screen-w*) (or h *screen-h*))))

(defmacro add-panel (list &rest panels)
  `(dolist (p ,panels) (push p ,list)))

(defmacro del-panel (list panel)
  `(setf ,list (delete ,panel ,list)))

(defun make-panel (x y w h)
  (make-instance 'panel :x x :y y :w w :h h))

(defun not-cull-p (x y w h)
  (or (not *current-panel*)
      (and (< x (panel-w *current-panel*))
	   (< y (panel-h *current-panel*))
	   (< -1 (+ x w))
	   (< -1 (+ y h)))))

(defun panel-contains-point-p (panel x y)
  (and (< -1 (- x  (panel-x panel)) (panel-w panel))
       (< -1 (- y (panel-y panel)) (panel-h panel))))

(defun find-panel-containing-point (panels x y)
  (find-if (lambda (p) (panel-contains-point-p p x y)) panels)) 

(defun %render-list (list)
  (apply (car list) (cdr list)))

(defmacro render-list (list)
  `(setf ,list (delete-if (lambda (p) (eq :delete (%render-list p))) ,list)))


(defmethod render-panel :around (panel)
  (let ((*current-panel* panel))
  (apply #'gl:scissor (panel-xywh panel))    
  (gl:with-pushed-matrix
    (gl:load-identity)
    (gl:translate (panel-x panel) (panel-y panel) 0)
    (call-next-method))))

(defmethod render-panel (panel)
  (render-list (panel-background panel))
  (render-list (panel-effects panel)))

(defun update-screen ()
  (gl:flush)
  (sdl-gl-swap-buffers))

(defun clear-screen ()
  (gl:clear :color-buffer-bit))

(defun render-all (panels x y)
  (clear-screen)
  (gl:enable :scissor-test)
  (map nil #'render-panel panels)
  (gl:disable :scissor-test)
  (gl:with-pushed-matrix
    (gl:translate x y 0)
    (map nil #'%render-list (mklist-list (mouse-at panels x y))))
  (update-screen))

;;;;============================================================================
;;;; Other PANELs
;;;;============================================================================

(defclass map-panel (panel)
  ((map
    :initarg :map
    :accessor map-panel)))

(defun make-map-panel (map x y w h)
  (let ((panel (make-instance 'map-panel :map map :x x :y y :w w :h h)))
    (dotimes (y (map-height map))
      (dotimes (x (map-width map))
	(when (terrain-at-* map x y)
	  (when (and (< 0 x (1- (map-width map))) (< 0 y (1- (map-height map))))
	    (let ((left (terrain-at-* map (1- x) y)) (right  (terrain-at-* map (1+ x) y))
		  (top  (terrain-at-* map x (1- y))) (bottom (terrain-at-* map x (1+ y)))
		  (x32 (* x 32.0)) (y32 (* y 32.0)))
	      (when (and (not top) (not left))
		(push (make-output-texture :cracks-tl x32 y32) (panel-background panel)))
	      (when (and (not top) (not right))
		(push (make-output-texture :cracks-tr x32 y32) (panel-background panel)))
	      (when (and (not bottom) (not left))
		(push (make-output-texture :cracks-bl x32 y32) (panel-background panel)))
	      (when (and (not bottom) (not right))
		(push (make-output-texture :cracks-br x32 y32) (panel-background panel)))))	  
	  (push (make-output-texture :rock-wall (* x 32.0) (* y 32.0)) (panel-background panel)))))
    panel))




;;;;============================================================================
;;;; Mouse stuff
;;;;============================================================================

(defparameter *mouse* nil
  "Association list of PANELs and mouse textures to be used for each DISPLAY")

(defun push-mouse (panel output)
  "Add a new mouse OUTPUT to be used as the mouse for PANEL area"
  (setf *mouse* (acons panel output *mouse*)))

(defun pop-mouse (panel)
  "Remove the top mouse texture used in PANEL area"
  (setf *mouse* (delete panel *mouse* :key #'car :count 1)))

(defun mouse-at (panels x y)
  "Find the mouse texture to be used for position X,Y among PANELS"
  (cdr (or (assoc (find-panel-containing-point panels x y) *mouse*)
	   (assoc nil *mouse*))))

